perm filename LOSS.1[MAC,LSP]4 blob
sn#557821 filedate 1981-01-15 generic text, type C, neo UTF8
COMMENT ā VALID 00002 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 SAIL LET add let! earlier
C00008 ENDMK
Cā;
;;; SAIL LET add let! earlier
;;; Does lambda binding
(declare (*fexpr code)(*expr %match macrobind %%destructurify%% %%expand%%
sail-letp)
(special %%clobber-macros%%))
(declare
(special *bindings *form *vars *vals *a *b *vars1 *vars2 *vals1 *vals2 ?t-w))
(defprop %match ((dsk (mac lsp)) match fas) autoload)
(defprop code ((dsk (mac lsp)) macrod fas) autoload)
(defun do-execute-memq (x)
(memq x '(do execute)))
(defun then-meanwhile-memq (x)
(memq x '(then meanwhile)))
(defun (let macro) (x)
(cond ((not (memq '/ā (cdr x)))
`(let! . ,(cdr x)))
(t
((lambda (q)
(cond ((and
*rset
(cond ((boundp '%%clobber-macros%%)
(not %%clobber-macros%%))
(t)))
q)
((atom q)
q)
(t (rplaca x (car q))
(rplacd x (cdr q)))))
((lambda (*bindings *form ?t-w)
(cond ((%match '(*bindings ($r ?t-w then-meanwhile-memq)
*form) (cdr x))
(cond ((eq ?t-w 'then)
(setq *form (ncons (cons 'let *form))))
(t
(setq *form (list (car *form)
(cons 'let (cdr *form)))))))
(t (%match '(*bindings
($r ? do-execute-memq)
*form) (cdr x))))
((lambda (*vars *vals)
(do ((*a nil *a)
(*b nil *b))
((null (%match '(*a ā *b)
*bindings))
((lambda (*vars1 *vals1 *vars2 *vals2)
(mapc
(function
(lambda
(q)
(and (car q)
(setq *vars1 (cons (car q) *vars1)
*vals1 (cons (cadr q) *vals1)))
(mapc
(function
(lambda (r)
(setq *vars2 (cons (car r) *vars2)
*vals2 (cons (cadr r) *vals2))))
(caddr q))))
(%%destructurify%% *vars *vals))
(setq *vars1 (nreverse *vars1)
*vars2 (nreverse *vars2)
*vals1 (nreverse *vals1)
*vals2 (nreverse *vals2))
(cond ((null *vars1)
(cond ((null *vars2)
(code (progn *form)))
(t
(code
((lambda (*vars2)
*form)
*vals2)))))
(t
(cond ((null *vars2)
(code
((lambda (*vars1)
*form)
*vals1)))
(t
(code ((lambda (*vars1)
((lambda (*vars2)
*form)
*vals2))
*vals1)))))))
nil nil nil nil))
(do ((n (1- (length *a))
(1- n))
(x (ncons (car *b))
(cons (car *b) x)))
((zerop n) (setq *bindings (cdr *b)
*b (nreverse x)))
(setq *b (cdr *b)))
(setq *vars (append
*vars *a)
*vals (append
*vals *b))))
nil nil)) nil nil nil))) ))
;(defun destructure (l)
; (destructure1 l nil))
(defun %%destructure1%% (l path)
(cond ((null l) nil)
((atom l)(ncons (cons l path)))
(t (append (%%destructure1%% (car l) (cons 'car path))
(%%destructure1%% (cdr l) (cons 'cdr path))))))
(defun %%destructurify%% (vars vals)
(mapcar
(function
(lambda (q r)
(cond ((atom q)
(list q r nil))
((atom r)
(list nil nil (%%pathify%% (%%destructure1%% q nil) r)))
(t ((lambda (g)
(list g r (%%pathify%% (%%destructure1%% q nil) g)))
(gensym))))))
vars vals))
(defun %%pathify%% (path gen)
(mapcar
(function
(lambda (q)
(list (car q) (%%code-path%% (cdr q) gen))))
path))
(defun %%code-path%% (path name)
(cond ((null path) name)
(t (list (car path) (%%code-path%% (cdr path) name)))))